home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / display-text.lisp < prev    next >
Encoding:
Text File  |  1991-07-26  |  53.5 KB  |  1,475 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                             AUSTIN, TEXAS 78714-9149                             |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1990, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23. (export '(
  24.       *default-display-text-font*
  25.       display-text
  26.       display-text-alignment
  27.       display-text-copy
  28.       display-text-field
  29.       display-text-font
  30.       display-text-selection 
  31.       display-text-source
  32.       edit-text-mark
  33.       edit-text-point
  34.       make-display-text
  35.       make-display-text-field
  36.       )
  37.     'clio-open)
  38.  
  39. ;;;----------------------------------------------------------------------------+
  40. ;;;                                                                            |
  41. ;;;                                select-text                                 |
  42. ;;;                                                                            |
  43. ;;;----------------------------------------------------------------------------+
  44.  
  45. (defcontact select-text ()
  46.   ((point :type     text-mark
  47.       :initform nil
  48.       :initarg  :point
  49.       :reader   edit-text-point)               ; setf defined below
  50.    
  51.    (mark  :type     text-mark
  52.       :initarg  :mark
  53.       :initform -1                       ; a value representing "undefined"
  54.       :reader   edit-text-mark))               ; setf defined below 
  55.   
  56.   (:resources point mark)
  57.  
  58.   (:documentation "Text that may be selected interactively."))
  59.  
  60.  
  61.  
  62. ;;;----------------------------------------------------------------------------+
  63. ;;;                                                                            |
  64. ;;;                            Selection Handling                              |
  65. ;;;                                                                            |
  66. ;;;----------------------------------------------------------------------------+
  67.  
  68.  
  69. (defgeneric (setf text-selection-displayed-p) (boolean text &optional exposed-x exposed-y exposed-width exposed-height)
  70.   (:documentation "Turn on/off the display of the current TEXT selection."))
  71.  
  72. (defmethod (setf text-selection-displayed-p) (boolean (text select-text) &optional
  73.                           exposed-x exposed-y exposed-width exposed-height)
  74.   (declare (ignore boolean))
  75.   (multiple-value-bind (from to) (text-selection-range text)
  76.     (when from
  77.       (text-change-highlight text from to exposed-x exposed-y exposed-width exposed-height))))
  78.  
  79. (defun text-selection-range (text)
  80.   (with-slots (point mark buffer) (the select-text text)
  81.     (multiple-value-bind (start end equal-p) (mark-range buffer point mark)
  82.       (unless equal-p
  83.     (values start end)))))
  84.  
  85. (defgeneric display-text-copy (text)
  86.   (:documentation "Causes the current TEXT selection to become the :CLIPBOARD selection.
  87. Returns the selected string."))
  88.  
  89. (defmethod display-text-selection ((text select-text))
  90.   (multiple-value-bind (start end) (text-selection-range text)
  91.     (when start
  92.       (display-text-source text :start start :end end))))
  93.  
  94. (defgeneric text-change-highlight (text from to &optional exposed-x exposed-y exposed-width exposed-height)
  95.   (:documentation "Turn on/off highlighting of TEXT between the FROM and TO positions."))
  96.   
  97. (defgeneric (setf text-caret-displayed-p)
  98.         (boolean text &optional exposed-x exposed-y exposed-width exposed-height)
  99.   (:documentation "Turn on/off the display of the TEXT caret."))
  100.  
  101.  
  102.  
  103.  
  104. ;;;----------------------------------------------------------------------------+
  105. ;;;                                                                            |
  106. ;;;                                 Accessors                                  |
  107. ;;;                                                                            |
  108. ;;;----------------------------------------------------------------------------+
  109.  
  110. (defmacro while-changing-marks ((text &optional time) &body body)
  111.   `(progn 
  112.      (setf (text-caret-displayed-p ,text) nil)
  113.  
  114.      ,@body
  115.  
  116.      ;; Update :primary ownership.
  117.      (text-own-selection ,text :primary ,time)
  118.  
  119.      (setf (text-caret-displayed-p ,text) t)))
  120.  
  121.  
  122. (defgeneric (setf edit-text-mark) (new-mark text)
  123.   (:documentation "Change the selection mark for the TEXT."))
  124.  
  125. (defmethod (setf edit-text-mark) (new-mark (text select-text))
  126.   (with-slots (buffer mark display) text
  127.     (unless (mark-equal new-mark mark)
  128.       (while-changing-marks (text (when (processing-event-p) (with-event (time) time)))
  129.     (text-change-highlight text new-mark mark)
  130.     (setf mark (move-mark mark new-mark)))))
  131.   new-mark)
  132.  
  133. (defgeneric (setf edit-text-point) (new-point text &key clear-p)
  134.   (:documentation "Change the insert point for the TEXT. If CLEAR-P is true,
  135. then the mark is also changed to clear the current selection."))
  136.  
  137. (defmethod (setf edit-text-point) (new-point (text select-text) &key clear-p)
  138.   (with-slots (display buffer point mark) text
  139.     (unless (mark-equal new-point point)
  140.       (while-changing-marks (text (when (processing-event-p) (with-event (time) time)))
  141.     (when clear-p (text-change-highlight text new-point mark))
  142.     (text-change-highlight text new-point point)
  143.  
  144.     ;; Update marks
  145.     (setf point (move-mark point new-point))
  146.     (when clear-p (setf mark (move-mark mark new-point))))))
  147.   new-point)
  148.  
  149.  
  150. (defmethod (setf display-text-source) :after (new-value (text select-text)
  151.                        &key (start 0) end (from-start 0) from-end)
  152.   (declare (ignore new-value start end from-start from-end)) 
  153.   (with-slots (buffer point mark) text
  154.     ;; Ensure valid insertion point and clear selection.
  155.     
  156.     ;; Note: primary method causes exposure and redisplay, so no need to update
  157.     ;; selection highlighting here.
  158.     (setf mark (move-mark mark (setf point (move-mark point (mark-range buffer point nil)))))))
  159.  
  160.  
  161. (defmethod display-text-copy ((text select-text))
  162.   (with-slots (point) text
  163.     (prog1
  164.       (clipboard-copy text)
  165.       (setf (edit-text-mark text) point))))
  166.  
  167. (defgeneric display-text-selection (text)
  168.   (:documentation "Returns the current TEXT selection."))
  169.  
  170.  
  171.  
  172. ;;;----------------------------------------------------------------------------+
  173. ;;;                                                                            |
  174. ;;;                          Initialization                                    |
  175. ;;;                                                                            |
  176. ;;;----------------------------------------------------------------------------+
  177.  
  178. (defmethod initialize-instance :after ((text select-text) &rest initargs)
  179.   (declare (ignore initargs))
  180.   (with-slots (point mark) text
  181.     (setf (edit-text-point text) point)
  182.     (setf (edit-text-mark text) (if (eql -1 mark) point mark))))
  183.  
  184.  
  185.  
  186. ;;;----------------------------------------------------------------------------+
  187. ;;;                                                                            |
  188. ;;;                              Event Handling                                |
  189. ;;;                                                                            |
  190. ;;;----------------------------------------------------------------------------+
  191.  
  192. (defevent select-text :selection-clear                       (text-selection-clear nil))
  193. (defevent select-text :selection-request                     text-selection-request)
  194. (defevent select-text (:button-press   :button-2)            text-adjust-selection)
  195. (defevent select-text (:button-press   :button-1 :meta)      display-text-copy)
  196. (defevent select-text (:button-release :button-1)            text-handle-release)
  197. (defevent select-text (:button-press   :button-1 :none :all) text-start-selection)
  198. (defevent select-text (:motion-notify  :button-1)            text-drag-selection)
  199.  
  200.  
  201.  
  202. (let ((new-mark (make-mark)))
  203.  
  204.   (defun text-start-selection (text)
  205.     (declare (type select-text text))
  206.     (with-slots (display mark point buffer) (the select-text text)
  207.       (with-event (x y time)
  208.     
  209.     ;; Undisplay either caret or current text selection.
  210.     (setf (text-selection-displayed-p text) nil)
  211.     (while-changing-marks (text time)
  212.       
  213.       (multiple-value-bind
  214.         (*current-left* *current-top* *current-width* *current-height* *current-ascent* *current-descent*)
  215.           (text-geometry text)
  216.         
  217.         (declare (special *current-left* *current-top*
  218.                   *current-width* *current-height*
  219.                   *current-ascent* *current-descent*))
  220.         
  221.         (let
  222.           ((new-mark            (text-point-mark text x y new-mark))
  223.            (*pointer-selection* t)
  224.            (display             (contact-display text)))
  225.           (declare (special *pointer-selection*))
  226.           
  227.           
  228.           ;; Initialize selection.
  229.           (setf
  230.         mark  (move-mark mark new-mark)
  231.         point (move-mark point new-mark))
  232.           
  233.           ;; Complete text selection interaction.
  234.           (catch :pointer-selection
  235.         (loop (process-next-event display)))
  236.           (apply-callback
  237.         text :point text (buffer-mark-position buffer point))))))))
  238.  
  239.  
  240.  
  241.   (defun text-drag-selection (text)
  242.     (declare (special *pointer-selection*))
  243.     (declare (type select-text text))
  244.     
  245.     (when (boundp '*pointer-selection*)
  246.       (with-event (x y)
  247.     (let ((new-mark (text-point-mark text x y new-mark)))
  248.       (with-slots (point) (the select-text text)
  249.         (text-change-highlight text point new-mark)
  250.         (setf point (move-mark point new-mark)))))))
  251.  
  252.   (defun text-adjust-selection (text)
  253.     (declare (type select-text text))
  254.     (when (text-selection-range text)
  255.       (with-event (x y)
  256.     (setf (edit-text-point text)
  257.           (text-point-mark text x y new-mark))
  258.     (with-slots (point buffer) (the select-text text)
  259.       (apply-callback text :point text (buffer-mark-position buffer point)))))))
  260.  
  261.  
  262. (defun text-handle-release (text)
  263.   (declare (ignore text))
  264.   (declare (special *pointer-selection*))
  265.   (when (boundp '*pointer-selection*) 
  266.     (throw :pointer-selection nil)))
  267.  
  268.  
  269.  
  270. ;;;----------------------------------------------------------------------------+
  271. ;;;                                                                            |
  272. ;;;                            Selection Ownership                             |
  273. ;;;                                                                            |
  274. ;;;----------------------------------------------------------------------------+
  275.  
  276. (defun display-selection-owner (display selection)
  277.   "Return the owner window and time of ownership for the SELECTION."
  278.   (declare (values window timestamp))
  279.   (let ((entry (getf (getf (display-plist display) 'selections) selection)))
  280.     (values
  281.       (first entry)          ; Owner window
  282.       (second entry))))          ; Timestamp
  283.  
  284. (defsetf display-selection-owner (display selection &optional timestamp) (owner) 
  285.   `(setf-display-selection-owner ,display ,selection ,timestamp ,owner))
  286.  
  287. (defun setf-display-selection-owner (display selection timestamp owner)
  288.   (declare (values window timestamp))
  289.   (assert (or (not owner) timestamp) nil
  290.       "Must give non-NIL timestamp for ~a to own ~s selection."
  291.       owner selection)
  292.   (let ((entry (or
  293.          (getf (getf (display-plist display) 'selections) selection)
  294.          (setf
  295.            (getf (getf (display-plist display) 'selections) selection)
  296.            (list nil nil)))))
  297.     (setf
  298.       (first entry)  owner
  299.       (second entry) timestamp)
  300.     (values owner timestamp)))
  301.  
  302.  
  303.  
  304. (defgeneric text-selection-clear (text selection)
  305.   (:documentation "Perform result of TEXT losing ownership of the given SELECTION."))
  306.  
  307. (defmethod text-selection-clear ((text contact) selection)
  308.   (with-slots (display) text
  309.     (setf (display-selection-owner display selection) nil)))
  310.  
  311. (defmethod text-selection-clear ((text contact) (selection null))
  312.   (text-selection-clear
  313.     text
  314.     (with-event ((event-selection selection)) event-selection)))
  315.  
  316. (defmethod text-selection-clear :after ((text select-text) (selection (eql :primary)))
  317.   (with-slots (point) text
  318.     (setf (edit-text-mark text) point)))
  319.  
  320.  
  321.  
  322. (defun text-selection-request (text)
  323.   (with-event (requestor selection target time property)
  324.     (selection-notify text requestor selection target time property)))
  325.  
  326. (defun selection-notify (text requestor selection target time property)
  327.   (declare (type select-text text)) 
  328.   (multiple-value-bind (property-name property-value property-format transform)
  329.       (text-convert-selection text selection property target time)
  330.     
  331.     (when property-name 
  332.       ;; Store converted reply property. 
  333.       (change-property
  334.     requestor property-name property-value target property-format :transform transform))
  335.     
  336.     ;; Send :selection-notify to requestor
  337.     (send-event requestor :selection-notify nil
  338.         :window requestor
  339.         :selection selection
  340.         :target target
  341.         :property property-name
  342.         :time time)
  343.  
  344.     ;; Return nil if failed to convert.
  345.     property-name))
  346.  
  347. (defgeneric text-convert-selection (text selection property target time)
  348.   (declare (values property value format transform))
  349.   (:documentation "Convert SELECTION (if owned by TEXT), to the given
  350. TARGET type. TIME is the time of the conversion request. PROPERTY 
  351. is the name of the property where the converted value should be stored.
  352.  
  353. Return values are the PROPERTY to be used (nil if conversion refused),
  354. the converted VALUE, the FORMAT of the value, and the TRANSFORM function
  355. to be used with change-property."))
  356.  
  357. (defmethod text-convert-selection (text selection property target time)
  358.   ;; Default method for converting a SELECTION. Since this is called when
  359.   ;; no other method exists, it always returns NIL to indicate that the SELECTION
  360.   ;; is not supported.
  361.   (declare (ignore text selection target time property))
  362.   nil)
  363.  
  364. (defmethod text-convert-selection :around (text selection (property null) target time)
  365.   ;; This method ensures conformance with the ICCCM convention that if no
  366.   ;; PROPERTY atom is given by the requestor, the TARGET atom is used as the
  367.   ;; name of the property where the converted value is stored.
  368.   (when (not (eq :multiple target))
  369.     (call-next-method text selection target target time)))
  370.  
  371. (defmethod text-convert-selection :around ((text contact) selection property (target (eql :multiple)) time)
  372.   (with-event (requestor)
  373.     (with-slots (display) text
  374.       (values
  375.     property
  376.  
  377.     ;; Value returned is list of targets, updated for failed conversions.
  378.     (do*
  379.       ((conversions
  380.          (get-property requestor property :transform #'(lambda (atom) (atom-name display atom))))
  381.        (targets
  382.          conversions (cddr targets)))
  383.       
  384.       ((endp targets)
  385.        ;; Crock! Have to apply the transform here to avoid a CLX R4.2 bug in change-property.
  386.        (mapcar
  387.          ;; Protocol encodes None atoms as 0. Future version of intern-atom should do this.
  388.          #'(lambda (a) (if a (intern-atom display a) 0))
  389.          conversions))
  390.       
  391.       (let ((target (first targets)) (property (second targets)))
  392.         (unless (selection-notify text requestor selection target time property)
  393.           ;; Mark failed target
  394.           (setf (getf conversions target) nil))))
  395.     
  396.     32))))
  397.  
  398. (defmethod convert-text ((text select-text) selection property target time)
  399.   (declare (type select-text text))
  400.   (with-slots (display buffer)
  401.     text ; (the select-text text)
  402.     (multiple-value-bind (owner owner-time) (display-selection-owner display selection)
  403.       (when
  404.       (and
  405.        ;; Selection owned?...
  406.        (eq text owner)
  407.          
  408.        ;; ...and Conversion time is...
  409.        (or
  410.         ;; ... CurrentTime?
  411.         (not time)
  412.            
  413.         ;; Crock! Remove this test when CLX maps CurrentTime correctly to nil!!
  414.         (zerop time)
  415.            
  416.         ;; ... later than owner time?
  417.         (> time owner-time)))
  418.        
  419.     ;; Convert successfully?
  420.     (case target
  421.          
  422.       ((:string :text)
  423.        (values property
  424.            (text-selection-string text selection)
  425.            8
  426.            #'xlib::char->card8))
  427.          
  428.       (:timestamp
  429.        (values property (list owner-time) 32 nil))
  430.          
  431.       (:targets
  432.        (values property
  433.            '(:string :text :targets :timestamp) 
  434.            32
  435.            #'(lambda (a) (intern-atom display a)))))))))
  436.  
  437. (defmethod text-convert-selection ((text select-text) (selection (eql :primary)) property target time)
  438.   (convert-text text selection property target time))
  439.  
  440. (defmethod text-convert-selection ((text select-text) (selection (eql :clipboard)) property target time)
  441.   (convert-text text selection property target time))
  442.  
  443.  
  444.  
  445. (defgeneric text-selection-string (text selection)
  446.   (declare (values string))
  447.   (:documentation "Return the TEXT string for the given SELECTION."))
  448.  
  449. (defmethod text-selection-string ((text select-text) (selection (eql :primary)))
  450.   (with-slots (buffer) text
  451.     (multiple-value-bind (start end) (text-selection-range text)
  452.       (if start (buffer-subseq buffer start end) ""))))
  453.  
  454.  
  455.  
  456.  
  457. (defgeneric text-own-selection (text selection time)
  458.   (declare (values own-p))
  459.   (:documentation "Assert TEXT (non)ownership of the SELECTION at the given TIME.
  460. This function should call (setf selection-owner) with owner as TEXT or nil, 
  461. as needed."))
  462.  
  463. (defmethod text-own-selection ((text contact) selection time)
  464.   (with-slots (display) text
  465.     (or
  466.       ;; Selection already owned?
  467.       (let ((owner (display-selection-owner display selection))) 
  468.     (unless (or (not owner) (eq owner text))
  469.       ;; Yes, change owner window.
  470.       (text-selection-clear owner selection)
  471.       
  472.       ;; Record new owner window/time.
  473.       (setf (selection-owner display selection time)
  474.         (setf (display-selection-owner display selection time) text)))
  475.     owner)
  476.       
  477.       ;; Selection ownership acquired?
  478.       (progn
  479.     (unless time
  480.       ;; Ensure actual timestamp is used, as per ICCCM.
  481.       (with-event-mode
  482.         (text
  483.           `((:property-notify :current-time)
  484.         ,#'(lambda (c) (declare (ignore c))
  485.                (with-event ((event-time time)) (setf time event-time)))))
  486.         
  487.         ;; Null property change just to generate a :property-notify timestamp
  488.         (change-property text :current-time nil :string 8 :mode :append)
  489.         
  490.         ;; Wait for :property-notify to be processed.
  491.         (do () (time) (process-next-event display))))
  492.     
  493.     ;; Ownership request successful?
  494.     (when (eq (setf (selection-owner display selection time) text)
  495.           (selection-owner display selection))
  496.       ;; Record owner window/time.
  497.       (setf (display-selection-owner display selection time) text))))))
  498.  
  499.  
  500. (defmethod text-own-selection ((text select-text) (selection (eql :primary)) time)
  501.   (with-slots (display point) text
  502.     ;; Need to own selection?
  503.     (if (text-selection-range text)
  504.     
  505.     ;; Yes, ownership request successful?
  506.     (or (call-next-method)
  507.         ;; No, abandon selection.
  508.         (when (setf (edit-text-mark text) point) nil)) 
  509.     
  510.     ;; No, abandon ownership, if necessary
  511.     (multiple-value-bind (owner owner-time) (display-selection-owner display selection)
  512.       (when (eq text owner)
  513.         (text-selection-clear text selection)
  514.         (setf (selection-owner display selection owner-time) nil))))))
  515.  
  516.  
  517.  
  518.  
  519.  
  520.  
  521. ;;;----------------------------------------------------------------------------+
  522. ;;;                                                                            |
  523. ;;;                            display-text-field                              |
  524. ;;;                                                                            |
  525. ;;;----------------------------------------------------------------------------+
  526.  
  527. (defparameter *default-display-text-font*
  528.           "-*-*-medium-r-*-*-*-*-*-*-*-*-iso8859-1")
  529.  
  530. (defparameter *default-display-text-field-font*
  531.           "-*-*-bold-r-*-*-*-*-*-*-*-*-iso8859-1")
  532.  
  533. (defcontact display-text-field (gravity-mixin core contact)
  534.   ((font      :type     fontable
  535.           :initform *default-display-text-field-font*
  536.           :reader   display-text-font           ; setf defined below
  537.           :initarg  :font)
  538.  
  539.    (buffer    :type     (or buffer buffer-line)
  540.           :initform (make-buffer-line)) 
  541.  
  542.    (compress-exposures
  543.               :initform :on))
  544.   
  545.   (:resources
  546.     (border-width :initform 0)
  547.     font
  548.     (source :type string :initform ""))
  549.  
  550.   (:documentation
  551.     "Presents a single line of text for viewing."))
  552.  
  553.  
  554. ;;;----------------------------------------------------------------------------+
  555. ;;;                                                                            |
  556. ;;;                                  Accessors                                 |
  557. ;;;                                                                            |
  558. ;;;----------------------------------------------------------------------------+
  559.  
  560. (defmethod (setf display-text-font) (new-value (text display-text-field))
  561.   (with-slots (font) text
  562.     (setf font (find-font text new-value)))
  563.  
  564.   ;; Save original fontname requested. Used again when changing scale.
  565.   (setf (getf (window-plist text) 'fontname) new-value)
  566.  
  567.   (multiple-value-bind (width height) (preferred-size text)
  568.     (change-geometry text :width width :height height :accept-p t))
  569.   
  570.   (when (realized-p text)
  571.     ;; Delay redisplay until :exposure handling to allow other class methods
  572.     ;; a chance to prepare for redisplay.
  573.     (clear-area text :exposures-p t))
  574.   
  575.   new-value)
  576.  
  577.  
  578. (defgeneric display-text-source (text &key start end)
  579.   (:documentation "Return the source substring of TEXT given by START/END."))
  580.  
  581. (defmethod display-text-source ((text display-text-field) &key (start 0) end)
  582.   (with-slots (buffer) text
  583.     (buffer-subseq buffer start end)))
  584.  
  585. (defgeneric (setf display-text-source) (new-string text &key start end from-start from-end)
  586.   (:documentation 
  587.      "Replace the source substring of TEXT given by START/END with the
  588.       substring of NEW-STRING given by FROM-START/FROM-END."))
  589.  
  590. (defmethod (setf display-text-source) (new-value (text display-text-field)
  591.                        &key (start 0) end (from-start 0) from-end)
  592.   (let ((new (string new-value)))
  593.     (with-slots (buffer) text
  594.       (buffer-delete buffer start end)
  595.       (buffer-insert buffer new start :start from-start :end from-end)
  596.  
  597.       (multiple-value-bind (width height) (preferred-size text)
  598.     (change-geometry text :width width :height height :accept-p t))
  599.       
  600.       (when (realized-p text)
  601.     ;; Delay redisplay until :exposure handling to allow other class methods
  602.     ;; a chance to prepare for redisplay.
  603.     (clear-area text :exposures-p t))
  604.       
  605.       new-value)))
  606.  
  607.  
  608. ;;;----------------------------------------------------------------------------+
  609. ;;;                                                                            |
  610. ;;;                                Initialization                              |
  611. ;;;                                                                            |
  612. ;;;----------------------------------------------------------------------------+
  613.  
  614. (defun make-display-text-field (&rest initargs)
  615.   (apply #'make-contact 'display-text-field initargs))
  616.  
  617. (defmethod initialize-instance :after ((text display-text-field) &key source &allow-other-keys)
  618.   (setf (display-text-font text) (slot-value text 'font))
  619.   (setf (display-text-source text) source))
  620.  
  621.  
  622. ;;;----------------------------------------------------------------------------+
  623. ;;;                                                                            |
  624. ;;;                                   Display                                  |
  625. ;;;                                                                            |
  626. ;;;----------------------------------------------------------------------------+
  627.  
  628. (defmethod display ((text display-text-field) &optional x y width height &key)
  629.   (declare (ignore x y width height))
  630.   (with-slots (buffer) text
  631.     (multiple-value-bind (x y) (text-base-point text)        
  632.       (text-display-chars text (buffer-line-chars buffer) x y)
  633.       
  634.       ;; Return base position for other methods to use
  635.       (values x y))))
  636.  
  637.  
  638. (defun text-display-chars (text chars x y &key (start 0) end)
  639.   (declare (type display-text-field text))
  640.   (with-slots (font foreground clip-rectangle) (the display-text-field text)
  641.     (let ((sensitive-p (sensitive-p text)))
  642.       (using-gcontext
  643.     (gcontext
  644.       :drawable   text
  645.       :font       font
  646.       :fill-style (unless sensitive-p :stippled)
  647.       :stipple    (unless sensitive-p (contact-image-mask text 50%gray :depth 1))
  648.       :foreground foreground
  649.       :clip-mask  clip-rectangle)
  650.     (draw-glyphs
  651.       text gcontext x y chars
  652.       :start start :end end)))))
  653.  
  654. (defgeneric text-refresh-line (text position &key clear-p base-x base-y)
  655.   (:documentation "Clear and redisplay one line of TEXT, beginning at the given POSITION."))
  656.  
  657. (defmethod text-refresh-line ((text display-text-field) (position integer) &key (clear-p t) base-x base-y)
  658.   (with-slots (buffer) text
  659.     (unless (and base-x base-y)
  660.       (multiple-value-setq (base-x base-y) (text-base-position text position)))
  661.     
  662.     ;; Clear line
  663.     (when clear-p
  664.       (text-clear-line text base-x base-y))
  665.       
  666.     ;; Redisplay chars
  667.     (text-display-chars
  668.       text (buffer-line-chars buffer)
  669.       base-x base-y :start position)))
  670.  
  671. (defmethod text-refresh-line ((text display-text-field) (position null) &key (clear-p t) base-x base-y)
  672.   ;; Nothing to do!
  673.   (declare (ignore clear-p base-x base-y)))
  674.  
  675. (defgeneric text-clear-line (text base-x base-y)
  676.   (:documentation "Clear one line of TEXT, beginning at the given base position."))
  677.  
  678. (defmethod text-clear-line ((text display-text-field) base-x base-y)
  679.   (with-slots (font) text
  680.     (clear-area
  681.       text
  682.       :x      base-x
  683.       :y      (- base-y (font-ascent font))
  684.       :height (+ (font-ascent font) (font-descent font)))))
  685.  
  686. (defmethod (setf text-caret-displayed-p) (boolean (text display-text-field)
  687.                       &optional exposed-x exposed-y exposed-width exposed-height)
  688.   ;; No caret displayed for non-editable text.
  689.   (declare (ignore exposed-x exposed-y exposed-width exposed-height))
  690.   boolean)
  691.  
  692.  
  693. ;;;----------------------------------------------------------------------------+
  694. ;;;                                                                            |
  695. ;;;                                   Geometry                                 |
  696. ;;;                                                                            |
  697. ;;;----------------------------------------------------------------------------+
  698.  
  699. (defgeneric display-text-extent (text)
  700.   (:documentation "Return the width, height, ascent, and descent of the TEXT extent rectangle."))
  701.  
  702. (defmethod display-text-extent ((text display-text-field))
  703.   (with-slots (buffer font) text
  704.     (multiple-value-bind (text-width a d l r font-ascent font-descent)
  705.     (text-extents font (buffer-line-chars buffer))
  706.       (declare (ignore a d l r))      
  707.       (values text-width (+ font-ascent font-descent) font-ascent font-descent))))
  708.  
  709. (defmethod rescale :before ((text display-text-field))
  710.   (with-slots (font) text
  711.     ;; Find font for new scale, using original fontname requested.
  712.     (setf font (find-font text (getf (window-plist text) 'fontname))))
  713.   (when (realized-p text)
  714.     (clear-area text :exposures-p t)))
  715.  
  716. (defmethod preferred-size ((text display-text-field) &key width height border-width)
  717.   (with-slots
  718.     ((contact-width width) (contact-height height) (contact-border-width border-width))
  719.     text
  720.     (multiple-value-bind (text-width text-height) (display-text-extent text)
  721.             
  722.       (values
  723.     (max text-width (or width contact-width))
  724.     (max text-height (or height contact-height))
  725.     (or border-width contact-border-width)))))
  726.  
  727.  
  728. (defgeneric text-geometry (text)
  729.   (:documentation
  730.     "Return the left, top, width, height, ascent, and descent of the TEXT extent rectangle."))
  731.  
  732. (defmethod text-geometry ((text display-text-field))
  733.   (declare (special *current-left* *current-top*
  734.             *current-width* *current-height*
  735.             *current-ascent* *current-descent*))
  736.   (if (boundp '*current-left*)
  737.       (values  *current-left* *current-top*
  738.            *current-width* *current-height*
  739.            *current-ascent* *current-descent*)
  740.       (compute-text-geometry text)))
  741.  
  742. (defgeneric compute-text-geometry (text)
  743.   (declare (values left top width height ascent descent)))
  744.  
  745. (defmethod compute-text-geometry ((text display-text-field)) 
  746.   (with-slots (gravity) (the display-text-field text)
  747.     (multiple-value-bind (width height ascent descent) (display-text-extent text)
  748.       (multiple-value-bind (left top)
  749.       
  750.       ;; Note: use FLOOR to compute position to be consistent with repositioning
  751.       ;; according to bit-gravity. Needed for small exposed regions to match
  752.       ;; up properly when redisplayed.
  753.       
  754.       (case gravity
  755.         (:north-west
  756.          (values
  757.            (display-clip-x text)
  758.            (display-clip-y text)))
  759.         
  760.         (:north
  761.          (values
  762.            (+ (display-clip-x text) (floor (- (display-clip-width text) width) 2))
  763.            (display-clip-y text)))
  764.         
  765.         (:north-east
  766.          (values
  767.            (+ (display-clip-x text) (- (display-clip-width text) width))
  768.            (display-clip-y text)))
  769.         
  770.         (:east
  771.          (values
  772.            (+ (display-clip-x text) (- (display-clip-width text) width))
  773.            (+ (display-clip-y text) (floor (- (display-clip-height text) height) 2))))
  774.         
  775.         (:center
  776.          (values
  777.            (+ (display-clip-x text) (floor (- (display-clip-width text) width) 2))
  778.            (+ (display-clip-y text) (floor (- (display-clip-height text) height) 2))))
  779.         
  780.         (:west
  781.          (values
  782.            (display-clip-x text)
  783.            (+ (display-clip-y text) (floor (- (display-clip-height text) height) 2))))
  784.         
  785.         (:south-east
  786.          (values
  787.            (+ (display-clip-x text) (- (display-clip-width text) width))
  788.            (+ (display-clip-y text) (- (display-clip-height text) height))))
  789.         
  790.         (:south
  791.          (values
  792.            (+ (display-clip-x text) (floor (- (display-clip-width text) width) 2))
  793.            (+ (display-clip-y text) (- (display-clip-height text) height))))
  794.         
  795.         (:south-west
  796.          (values
  797.            (display-clip-x text)
  798.            (+ (display-clip-y text) (- (display-clip-height text) height)))))
  799.     
  800.     (values left top width height ascent descent)))))
  801.  
  802.  
  803. (defun text-base-point (text)
  804.   "Return the left baseline endpoint for the TEXT."
  805.   (multiple-value-bind (left top w h ascent) (text-geometry text)
  806.     (declare (ignore w h))
  807.     (values left (+ top ascent))))
  808.  
  809. (defgeneric text-base-position (text position)
  810.   (:documentation "Return the left baseline endpoint for the TEXT substring
  811. beginning at the given POSITION."))
  812.  
  813. (defmethod text-base-position ((text display-text-field) (position integer))
  814.   (with-slots (font buffer) text
  815.     (multiple-value-bind (start-x start-y) (text-base-point text)
  816.       (unless (zerop position)
  817.     (incf start-x (text-width font (buffer-line-chars buffer) :end position)))
  818.       (values start-x start-y))))
  819.  
  820. (defmethod text-base-position ((text display-text-field) (position null))
  821.   (with-slots (buffer) text
  822.     (text-base-position text (length (buffer-line-chars buffer)))))
  823.  
  824.  
  825.  
  826. (defgeneric text-point-mark (text x y &optional mark)
  827.   (:documentation "Return the text-mark corresponding to the given X/Y point."))
  828.  
  829.  
  830. (defmethod text-point-mark ((text display-text-field) x y &optional mark)
  831.   (declare (ignore mark))
  832.   (with-slots (buffer) text
  833.   
  834.     ;; Compute extent.
  835.     (multiple-value-bind (left top width height)
  836.     (text-geometry text) 
  837.  
  838.       (cond
  839.     (;; Return first position if above or left of extent
  840.      (or (< x left) (< y top))
  841.      0)
  842.     
  843.     (;; Return end position if below or righ of extent
  844.      (or (>= x (+ left width)) (>= y (+ top height)))
  845.      (buffer-length buffer))
  846.     
  847.     (t
  848.      (text-point-index text nil left x))))))
  849.  
  850.  
  851. (defgeneric text-point-index (text line left x)
  852.   (:documentation "Return the index of the character in the given LINE of the TEXT
  853. which is at the given X position. LEFT gives the left edge position of the TEXT extent 
  854. rectangle."))
  855.  
  856. (let ((char-string (make-string 1))
  857.       (char-index  (make-array 1 :element-type 'card8)))
  858.   
  859.  
  860.   (defmethod text-point-index ((text display-text-field) line left x)
  861.     (declare (ignore line))
  862.     
  863.     (with-slots (font buffer) text
  864.       (do* ((index-x left)
  865.         (index   0)
  866.         (chars  (buffer-line-chars buffer))
  867.         (max    (length chars)))
  868.        
  869.        ((= index max) index)
  870.     
  871.     (setf (elt char-string 0) (elt chars index))
  872.     (translate-default char-string 0 1 font char-index 0)
  873.     (let ((char-width (char-width font (elt char-index 0))))
  874.       (when (> (+ index-x (pixel-round char-width 2)) x)
  875.         (return index))
  876.       
  877.       (incf index-x char-width)
  878.       (incf index))))))
  879.  
  880. (defgeneric text-point-line (text top ascent descent y)
  881.   (:documentation "Return the line of the given Y position for the TEXT, given
  882. the TOP, ASCENT, DESCENT of the TEXT extent rectangle."))
  883.  
  884.  
  885. (defmethod text-point-line ((text display-text-field) top ascent descent y)
  886.   (declare (ignore top ascent descent y))
  887.   0)
  888.  
  889.  
  890. (defgeneric text-mark-point (text mark)
  891.   (:documentation "Return the X/Y point corresponding to the given TEXT mark."))
  892.  
  893. (defmethod text-mark-point ((text display-text-field) mark)
  894.   ;; Compute extent.
  895.   (multiple-value-bind (left top w h ascent) 
  896.       (text-geometry text)
  897.     (declare (ignore w h))
  898.     
  899.     (with-slots (buffer font) text
  900.       (values
  901.     (+ left (buffer-text-extents buffer font 0 mark))
  902.     (+ top ascent)))))
  903.  
  904.  
  905. ;;;----------------------------------------------------------------------------+
  906. ;;;                                                                            |
  907. ;;;                               display-text                                 |
  908. ;;;                                                                            |
  909. ;;;----------------------------------------------------------------------------+
  910.  
  911. (defcontact display-text (select-text display-text-field)
  912.   ((buffer    :type     buffer
  913.           :initform (make-buffer))
  914.  
  915.    (alignment :type     (member :left :center :right)
  916.           :initform :left
  917.           :initarg  :alignment
  918.           :accessor display-text-alignment)
  919.  
  920.    (extent-top       
  921.               :type     integer)
  922.    (extent-left      
  923.               :type     integer)
  924.    (extent-width
  925.               :type     (integer 0 *))
  926.    (extent-height
  927.               :type     (integer 0 *))
  928.  
  929.    (compress-exposures
  930.               :initform :off))
  931.   
  932.   (:resources
  933.     alignment
  934.     (font :initform  *default-display-text-font*))
  935.  
  936.   (:documentation
  937.     "Presents multiple lines of text for viewing."))
  938.  
  939.  
  940.  
  941. ;;;----------------------------------------------------------------------------+
  942. ;;;                                                                            |
  943. ;;;                              Initialization                                |
  944. ;;;                                                                            |
  945. ;;;----------------------------------------------------------------------------+
  946.  
  947. (defun make-display-text (&rest initargs)
  948.   (apply #'make-contact 'display-text initargs))
  949.  
  950.  
  951. ;;;----------------------------------------------------------------------------+
  952. ;;;                                                                            |
  953. ;;;                                 Accessors                                  |
  954. ;;;                                                                            |
  955. ;;;----------------------------------------------------------------------------+
  956.  
  957.  
  958. (defun text-extent-defined-p (text)
  959.   (slot-boundp text 'extent-top))
  960.  
  961. (defsetf text-extent-defined-p (text) (boolean)
  962.   (declare (ignore boolean))
  963.   `(slot-makunbound ,text 'extent-top))
  964.  
  965. (defmethod (setf display-text-source) :after (new-value (text display-text)
  966.                             &key (start 0) end (from-start 0) from-end)
  967.   (declare (ignore new-value start end from-start from-end))
  968.   (setf (text-extent-defined-p text) nil))
  969.  
  970. (defmethod (setf display-gravity) :after (new-value (text display-text))
  971.   (declare (ignore new-value))
  972.   (setf (text-extent-defined-p text) nil))
  973.  
  974. (defmethod (setf display-text-font) :after (new-value (text display-text))
  975.   (declare (ignore new-value))
  976.   (setf (text-extent-defined-p text) nil))
  977.  
  978. (defmethod (setf display-text-alignment) :before (new-value (text display-text))
  979.   (check-type new-value (member :left :center :right)
  980.           "one of :LEFT, :CENTER, or :RIGHT"))
  981.  
  982. (defmethod (setf display-text-alignment) :after (new-value (text display-text))
  983.   (declare (ignore new-value))
  984.   (setf (text-extent-defined-p text) nil)
  985.   (when (realized-p text)
  986.     ;; Delay redisplay until :exposure handling to allow other class methods
  987.     ;; a chance to prepare for redisplay.
  988.     (clear-area text :exposures-p t)))
  989.  
  990. (defmethod (setf display-bottom-margin) :after (new-value (text display-text))
  991.   (declare (ignore new-value))
  992.   (setf (text-extent-defined-p text) nil))
  993.  
  994. (defmethod (setf display-left-margin) :after (new-value (text display-text))
  995.   (declare (ignore new-value))
  996.   (setf (text-extent-defined-p text) nil))
  997.  
  998. (defmethod (setf display-right-margin) :after (new-value (text display-text))
  999.   (declare (ignore new-value))
  1000.   (setf (text-extent-defined-p text) nil))
  1001.  
  1002. (defmethod (setf display-top-margin) :after (new-value (text display-text))
  1003.   (declare (ignore new-value))
  1004.   (setf (text-extent-defined-p text) nil))
  1005.  
  1006. ;;;----------------------------------------------------------------------------+
  1007. ;;;                                                                            |
  1008. ;;;                                  Display                                   |
  1009. ;;;                                                                            |
  1010. ;;;----------------------------------------------------------------------------+
  1011.  
  1012. (defmethod display ((text display-text) &optional exposed-x exposed-y exposed-width exposed-height &key)
  1013.   (with-slots (width height) text
  1014.     (text-refresh
  1015.       text 0 nil nil
  1016.       (or exposed-x 0) (or exposed-y 0)
  1017.       exposed-width exposed-height))
  1018.     
  1019.   ;; Display caret or current selection
  1020.   (setf (text-selection-displayed-p text exposed-x exposed-y exposed-width exposed-height) t)
  1021.   (setf (text-caret-displayed-p text exposed-x exposed-y exposed-width exposed-height) t))
  1022.  
  1023.  
  1024. (let ((char-string (make-string 1))
  1025.       (char-index  (make-array 1 :element-type 'card8)))
  1026.   
  1027.   (defun text-clipped-line (text line start end clip-left clip-right)
  1028.     "Clip the substring of LINE in TEXT given by START/END to the horizontal region
  1029. between CLIP-LEFT and CLIP-RIGHT. Returns the start/end indexes and the left x position
  1030. of the clipped substring."
  1031.     (declare (type display-text text))
  1032.     
  1033.     (flet
  1034.       ((actual-width (font char)
  1035.     (cond
  1036.       ((graphic-char-p char)
  1037.        (setf (elt char-string 0) char)
  1038.        (translate-default char-string 0 1 font char-index 0)
  1039.        (char-width font (elt char-index 0)))
  1040.       (t 0))))
  1041.                    
  1042.     (with-slots (font buffer) (the display-text text)
  1043.       (let*
  1044.     ((index-x (text-base-x text line))
  1045.      (index   0)
  1046.      
  1047.      (chars   (buffer-line-chars (elt (buffer-lines buffer) line)))
  1048.      (max     (length chars))
  1049.      (end     (if end (min max end) max))
  1050.  
  1051.      (start   (do (char-right)
  1052.               ((= index end) index)
  1053.             
  1054.             ;; Find right edge of next char 
  1055.             (setf char-right (+ index-x (actual-width font (elt chars index))))
  1056.             
  1057.             ;; Is this the first char in start/end subseq that intersects
  1058.             ;; the clip region?
  1059.             (when (and (>= index start) (> char-right clip-left))
  1060.               (return index))
  1061.             
  1062.             ;; Setf index-x to left edge of next char
  1063.             (incf index)
  1064.             (setf index-x char-right)))
  1065.      
  1066.      (start-x index-x))
  1067.  
  1068.     (values
  1069.       start
  1070.       
  1071.       ;; Find end of clipped substring.
  1072.       (do ()          
  1073.           ;; Is this the last char in start/end subseq past that intersects
  1074.           ;; the clip region?
  1075.           ((or (>= index-x clip-right) (= index end)) index)
  1076.         
  1077.         ;; Find left edge of next char.
  1078.         (incf index-x (actual-width font (elt chars index)))
  1079.         (incf index))
  1080.  
  1081.       start-x))))))
  1082.  
  1083. (defgeneric text-refresh (text start end &optional clear-p exposed-x exposed-y exposed-width exposed-height)
  1084.   (:documentation "Draw TEXT characters from START to END. By default CLEAR-P is true, in which case the displayed 
  1085. area is cleared first. If EXPOSED-X, EXPOSED-Y, EXPOSED-WIDTH, and EXPOSED-HEIGHT are given, then 
  1086. characters are refreshed only if they lie in the exposed area."))
  1087.  
  1088.  
  1089. (defmethod text-refresh ((text display-text) (start mark) (end mark)
  1090.                &optional (clear-p t) (exposed-x 0) (exposed-y 0) exposed-width exposed-height) 
  1091.   ;; Update extent cache
  1092.   (text-geometry text)
  1093.   
  1094.   (with-slots (buffer font extent-left extent-top extent-width extent-height width height) text
  1095.     
  1096.     ;; Redisplay only text inside the exposed region.
  1097.     (multiple-value-bind (exposed-x exposed-y exposed-width exposed-height)
  1098.     (area-overlaps-p
  1099.       exposed-x exposed-y (or exposed-width (- width exposed-x)) (or exposed-height (- height exposed-y))
  1100.       extent-left extent-top extent-width extent-height)
  1101.       
  1102.       (when exposed-x
  1103.     (let*
  1104.       ((ascent         (font-ascent font))
  1105.        (descent        (font-descent font))
  1106.        (exposed-right  (+ exposed-x exposed-width)) 
  1107.        
  1108.        (sli            (mark-line-index start))
  1109.        (next-line      (max sli
  1110.                 (text-point-line
  1111.                   text extent-top ascent descent
  1112.                   exposed-y)))
  1113.        
  1114.        (eli            (mark-line-index end))
  1115.        (end-line       (min eli
  1116.                 (text-point-line
  1117.                   text extent-top ascent descent
  1118.                   (+ exposed-y exposed-height))))
  1119.        
  1120.        (nlines         (1+ (- end-line next-line)))
  1121.        (lines          (buffer-lines buffer))
  1122.        (line-height    (+ ascent descent))
  1123.        (base-y         (+ extent-top ascent (* next-line line-height)))) 
  1124.       
  1125.       
  1126.       (dotimes (i nlines)
  1127.         (multiple-value-bind (start end start-x)
  1128.         (text-clipped-line text next-line
  1129.                    (if (unless clear-p (= next-line sli))
  1130.                        (mark-index start)
  1131.                        0)
  1132.                    (if (unless clear-p (= next-line eli))
  1133.                        (mark-index end)
  1134.                        nil)
  1135.                    exposed-x exposed-right)
  1136.           
  1137.           (text-display-chars
  1138.         text (buffer-line-chars (elt lines next-line))
  1139.         start-x base-y
  1140.         :start start
  1141.         :end end)
  1142.           (incf next-line)
  1143.           (incf base-y line-height))))))))
  1144.  
  1145.  
  1146. (let ((start-mark (make-mark))
  1147.       (end-mark (make-mark)))
  1148.  
  1149.   (defmethod text-refresh ((text display-text) start end
  1150.                &optional (clear-p t) (exposed-x 0) (exposed-y 0) exposed-width exposed-height)
  1151.     (with-slots (buffer) text
  1152.       (text-refresh
  1153.     text
  1154.     (if (or (null start) (integerp start))
  1155.         (buffer-position-mark buffer start start-mark)
  1156.         start)
  1157.     (if (or (null end) (integerp end))
  1158.         (buffer-position-mark buffer end end-mark)
  1159.         end)
  1160.     clear-p exposed-x exposed-y exposed-width exposed-height))))
  1161.  
  1162.  
  1163.  
  1164. (defmethod text-change-highlight ((text display-text) (from mark) (to mark)
  1165.                   &optional exposed-x exposed-y exposed-width exposed-height)
  1166.   (when (realized-p text)    
  1167.   (with-slots (font buffer foreground  clip-rectangle) text
  1168.     
  1169.     (multiple-value-bind (from to equal-p) (mark-range buffer from to)
  1170.       (unless equal-p
  1171.     (let*
  1172.       ((lines       (buffer-lines buffer))
  1173.        (ascent      (font-ascent font))
  1174.        (descent     (font-descent font))
  1175.        (line-height (+ ascent descent))
  1176.        (fli         (mark-line-index from))
  1177.        (tli         (mark-line-index to)))
  1178.  
  1179.       (flet
  1180.         ((draw-highlight
  1181.           (gc)
  1182.           ;; Draw highlight for all chars between from and to marks.
  1183.           (do ((line fli (1+ line))
  1184.            (y (- (text-base-y text fli ascent descent) ascent) (+ y line-height)))
  1185.           ((> line tli))
  1186.         
  1187.         (let ((start-index (if (= line fli) (mark-index from) 0)))
  1188.           (draw-rectangle
  1189.             text gc
  1190.             (text-base-x text line start-index) y
  1191.             (text-width
  1192.               font (buffer-line-chars (elt lines line))
  1193.               :start start-index
  1194.               :end (when (= line tli) (mark-index to)))
  1195.             line-height
  1196.             t)))))
  1197.         
  1198.         (using-gcontext
  1199.           (gc :drawable   text
  1200.           :function   boole-xor
  1201.           :clip-mask  clip-rectangle
  1202.           :foreground (logxor
  1203.                 foreground
  1204.                 (contact-current-background-pixel text)))
  1205.           
  1206.           (if exposed-x
  1207.           
  1208.           ;; Clip highlight to intersection of clip rectangle and exposed region.
  1209.           (let
  1210.             ((old-clip-x      (display-clip-x text))
  1211.              (old-clip-y      (display-clip-y text))
  1212.              (old-clip-width  (display-clip-width text))
  1213.              (old-clip-height (display-clip-height text)))
  1214.  
  1215.             (multiple-value-bind (new-clip-x new-clip-y new-clip-width new-clip-height)
  1216.             (area-overlaps-p
  1217.               old-clip-x old-clip-y old-clip-width old-clip-height
  1218.               exposed-x exposed-y exposed-width exposed-height)
  1219.  
  1220.               (when new-clip-x
  1221.             (setf
  1222.               (display-clip-x text)      new-clip-x
  1223.               (display-clip-y text)      new-clip-y
  1224.               (display-clip-width text)  new-clip-width
  1225.               (display-clip-height text) new-clip-height)
  1226.             
  1227.             ;; Draw highlight when intersection exists.
  1228.             (with-gcontext (gc :clip-mask clip-rectangle)
  1229.               (draw-highlight gc))
  1230.             
  1231.             ;; Restore clip rectangle
  1232.             (setf (display-clip-x text)      old-clip-x
  1233.                   (display-clip-y text)      old-clip-y
  1234.                   (display-clip-width text)  old-clip-width
  1235.                   (display-clip-height text) old-clip-height))))
  1236.           
  1237.           ;; Else draw highlight without additional clipping
  1238.           (draw-highlight gc))))))))))
  1239.       
  1240.       
  1241. ;;;----------------------------------------------------------------------------+
  1242. ;;;                                                                            |
  1243. ;;;                                 Geometry                                   |
  1244. ;;;                                                                            |
  1245. ;;;----------------------------------------------------------------------------+
  1246.  
  1247. (defmethod resize :after ((text display-text) width height border-width)
  1248.   (declare (ignore width height border-width))
  1249.   (setf (text-extent-defined-p text) nil))
  1250.  
  1251. (defmethod display-text-extent ((text display-text))
  1252.   (with-slots (buffer font) text
  1253.     (let ((ascent  (font-ascent font))
  1254.       (descent (font-descent font))
  1255.       (lines   (buffer-lines buffer)))
  1256.       (values
  1257.     (reduce #'(lambda (max-width line)
  1258.             (max max-width (text-width font (buffer-line-chars line))))
  1259.         lines :initial-value 0)
  1260.     (* (+ ascent descent) (length lines))
  1261.     ascent
  1262.     descent))))
  1263.  
  1264. (defmethod text-geometry ((text display-text))
  1265.   (with-slots (font extent-top extent-left extent-width extent-height) text
  1266.     (multiple-value-bind (ascent descent)
  1267.     (if (text-extent-defined-p text)
  1268.         (values (font-ascent font) (font-descent font))
  1269.  
  1270.         ;; Update extent slots with current geometry.
  1271.         (multiple-value-bind (left top w h a d) (compute-text-geometry text)
  1272.           (setf extent-left   left
  1273.             extent-top    top
  1274.             extent-width  w
  1275.             extent-height h)
  1276.           (values a d)))
  1277.  
  1278.       (values extent-left extent-top extent-width extent-height ascent descent))))
  1279.  
  1280. (defmethod text-point-mark ((text display-text) x y &optional mark)
  1281.   (with-slots (font buffer extent-top extent-left extent-width extent-height) text  
  1282.     (let
  1283.       ((mark (or mark (make-mark)))
  1284.        (line (text-point-line
  1285.            text extent-top
  1286.            (font-ascent font) (font-descent font)
  1287.            (max extent-top (min (1- (+ extent-top extent-height)) y)))))
  1288.       (setf (mark-buffer mark) buffer)
  1289.       (move-mark mark line (text-point-index text line (text-base-x text line) x)))))
  1290.  
  1291. (defun text-base-x (text line &optional (start 0))
  1292.   "Return the left edge of the START position of the LINE in the TEXT."
  1293.   (declare (type display-text text)
  1294.        (type integer     line))
  1295.   (declare (values int16))
  1296.  
  1297.   ;; Ensure extent is defined.
  1298.   (text-geometry text)
  1299.   
  1300.   (with-slots (font buffer alignment extent-left extent-width) (the display-text text)
  1301.     (let ((chars (buffer-line-chars (elt (buffer-lines buffer) line))))
  1302.       (+ (case alignment
  1303.        (:left   extent-left)
  1304.        (:center (+ extent-left (floor (- extent-width (text-width font chars)) 2)))
  1305.        (:right  (+ extent-left (- extent-width (text-width font chars)))))
  1306.      
  1307.      (if (plusp start)
  1308.          (text-width font chars :end start)
  1309.          0)))))
  1310.  
  1311. (defun text-base-y (text line &optional ascent descent)
  1312.   "Return the baseline position of the LINE in the TEXT."
  1313.   (declare (type display-text text)
  1314.        (type integer     line))
  1315.   (declare (values integer))
  1316.  
  1317.   ;; Ensure extent is defined.
  1318.   (text-geometry text) 
  1319.   
  1320.   (with-slots (font extent-top) (the display-text text)
  1321.     (+ extent-top
  1322.        (* line (+ (or ascent (setf ascent (font-ascent font)))
  1323.           (or descent (font-descent font))))
  1324.        ascent)))
  1325.  
  1326. (defmethod text-base-position ((text display-text) (position mark))
  1327.   (let ((line (mark-line-index position)))
  1328.     (values
  1329.       (text-base-x text line (mark-index position))
  1330.       (text-base-y text line))))
  1331.  
  1332. (let ((mark (make-mark)))
  1333.   (defmethod text-base-position ((text display-text) position)
  1334.     (with-slots (buffer) text
  1335.       (setf (mark-buffer mark) buffer)
  1336.       (text-base-position text (buffer-position-mark buffer position mark)))))
  1337.  
  1338.  
  1339.  
  1340. (let ((char-string (make-string 1))
  1341.       (char-index  (make-array 1 :element-type 'card8)))
  1342.   
  1343.   (defmethod text-point-index ((text display-text) line left x)
  1344.     (with-slots (font buffer) text
  1345.       (do* ((index-x left)
  1346.         (index   0 (1+ index))
  1347.         (chars  (buffer-line-chars (elt (buffer-lines buffer) line)))
  1348.         (max    (let* ((max (length chars)) (last (1- max)))
  1349.               ;; Can't point or insert after #\newline!
  1350.               (if (and (plusp max) (eql #\newline (elt chars last))) last max))))
  1351.        
  1352.        ((= index max) index)
  1353.     
  1354.     (let ((char (elt chars index)))
  1355.       (when (graphic-char-p char)
  1356.         (setf (elt char-string 0) char)
  1357.         (translate-default char-string 0 1 font char-index 0)
  1358.         (let ((char-width (char-width font (elt char-index 0))))
  1359.           (when (> (+ index-x (pixel-round char-width 2)) x)
  1360.         (return index))      
  1361.           (incf index-x char-width))))))))
  1362.        
  1363.        
  1364.        
  1365. (defmethod text-point-line ((text display-text) top ascent descent y)
  1366.   (floor (- y top) (+ ascent descent)))
  1367.  
  1368. (defmethod text-mark-point ((text display-text) (mark mark))
  1369.   (with-slots (font buffer extent-top) text
  1370.     (let ((ascent (font-ascent font))
  1371.       (line   (mark-line-index mark)))
  1372.       (values
  1373.     (text-base-x text line (mark-index mark))
  1374.     (+ extent-top (* line (+ ascent (font-descent font))) ascent)))))
  1375.  
  1376.  
  1377.  
  1378.  
  1379.  
  1380.  
  1381.  
  1382. ;;;----------------------------------------------------------------------------+
  1383. ;;;                                                                            |
  1384. ;;;                                 Selection                                  |
  1385. ;;;                                                                            |
  1386. ;;;----------------------------------------------------------------------------+
  1387.  
  1388.  
  1389. (defmethod (setf edit-text-point) :before (new-value (text display-text) &key clear-p)
  1390.   (declare (ignore new-value clear-p))
  1391.   (with-slots (point buffer) text
  1392.     ;; Allocate point if necessary.
  1393.     (unless (mark-p point) (setf point (make-mark :buffer buffer)))))
  1394.  
  1395.  
  1396. (defmethod edit-text-point :around ((text display-text))
  1397.   (with-slots (buffer) text
  1398.     (buffer-mark-position buffer (call-next-method))))
  1399.  
  1400. (let ((mark (make-mark)))
  1401.   (defmethod (setf edit-text-point) :around ((new-value integer) (text display-text) &key clear-p)
  1402.     (with-slots (buffer) text
  1403.       (call-next-method
  1404.     (buffer-position-mark buffer new-value mark)
  1405.     text :clear-p clear-p))
  1406.     new-value))
  1407.  
  1408.  
  1409. (defmethod (setf edit-text-mark) :before (new-value (text display-text))
  1410.   (declare (ignore new-value))
  1411.   (with-slots (mark buffer) text
  1412.     ;; Allocate mark if necessary.
  1413.     (unless (mark-p mark) (setf mark (make-mark :buffer buffer)))))
  1414.  
  1415. (defmethod edit-text-mark :around ((text display-text))
  1416.   (with-slots (buffer) text
  1417.     (buffer-mark-position buffer (call-next-method))))
  1418.  
  1419. (let ((mark (make-mark)))
  1420.   (defmethod (setf edit-text-mark) :around ((new-value integer) (text display-text))
  1421.     (with-slots (buffer) text
  1422.       (call-next-method
  1423.     (buffer-position-mark buffer new-value mark)
  1424.     text))
  1425.     new-value))
  1426.  
  1427.  
  1428.  
  1429. ;;;----------------------------------------------------------------------------+
  1430. ;;;                                                                            |
  1431. ;;;                            Clipboard Handling                              |
  1432. ;;;                                                                            |
  1433. ;;;----------------------------------------------------------------------------+
  1434.  
  1435.  
  1436. ;;; When text is copied or cut to the Clipboard, then the client becomes the owner 
  1437. ;;; of the :CLIPBOARD selection.  During this time, the current :CLIPBOARD value is
  1438. ;;; a string stored on the display plist.  (The current :CLIPBOARD value is unique to
  1439. ;;; server; in particular, individual text contacts do not need to store this value
  1440. ;;; independently.) To minimize garbage, the display-clipboard-text is an adjustable
  1441. ;;; string vector which is reused.
  1442.  
  1443. (defmacro display-clipboard-text (display)
  1444.   `(getf (display-plist ,display) 'clipboard-text))
  1445.  
  1446. (defsetf display-clipboard-text setf-display-clipboard-text)
  1447. (defun setf-display-clipboard-text (display string)
  1448.   (let
  1449.     ;; Create string vector, if necessary.
  1450.     ((clipboard (or (display-clipboard-text display)
  1451.             (mawTO-----------ay-clipb-r-line-charsh char*        :table
  1452. ;;; xt e        :fixt-) :ar;; 0        :nt-type 'card8r-line-widtdo 
  1453.       (valdesce)))e    (vaeatDnt-int reviousacts ypes ((clipr, if entt-intoard-text    (vaeatStew-valuacts ypes plustable
  1454. or, if necessary.
  1455.     ((clip(> (+g vect  (move-mle-value-bind disq ((isce)))etoard-text      pr, if et afteroard (or (0 g 0 1 fonth charsg)
  1456.   (l    (setf (mark-(display-plist ,dispay) 'clipboard-text))
  1457.  
  1458. (dtoard-text     (g)
  1459.   (lefun text-oard-text)d oxt line)eclare (type display-text text-fielt-mark)  (with-slots (font r new-vay) 'clip    (let ((ascen then (> (+ prory.
  1460.   (-evype  ascslotsevype n the), the
  1461. (le 
  1462.   (move-mle-value-bind (left  0))
  1463.  tlyxt disp-tion.  Du-ate th
  1464.        (tand (plus 0))
  1465.   disp- 
  1466. ;-tion.  Du :clear-prd (or ( the
  1467. (
  1468.  (setf (elt cay-clipboard-text display)
  1469.           fer-mark-subseqer new-v 0))
  1470.  tlyx(line (setf (> (+g ))
  1471.    (when (adex"~a ~a.~%~a"  (mawT" poeed acquirIPBOARD selection.  Du)))r"  (mawT    ( (mawT"Tispleed d or cuoreoard, the."))
  1472.        
  1473. method text-mark-tion.  Du-g (make-(setf-dion. ) (mark tion.  Du)#\new:oard-text   with-slots (font ay) 'clip    (let (ay-clipboard-text display)
  1474.           
  1475. ;;;--